home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacGambit 2.0 / sources2 / Interp⁄Comp (.scm) / ptree1.scm < prev    next >
Encoding:
Text File  |  1992-06-04  |  73.3 KB  |  2,006 lines  |  [TEXT/gamI]
  1. rse tree.
  2.  
  3. ; These structures define the nodes associated to expressions.
  4.  
  5. ; information common to all nodes
  6.  
  7. ;  parent   ; the node of which this node is a child
  8. ;  children ; list of parse-trees of the sub-expressions
  9. ;  fv       ; set of free/non-global vars contained in this expr
  10. ;  decl     ; declarations that apply to this node
  11. ;  source   ; source corresponding to this node
  12.  
  13. (define (node-parent x)          (vector-ref x 1))
  14. (define (node-children x)        (vector-ref x 2))
  15. (define (node-fv x)              (vector-ref x 3))
  16. (define (node-decl x)            (vector-ref x 4))
  17. (define (node-source x)          (vector-ref x 5))
  18. (define (node-parent-set! x y)   (vector-set! x 1 y))
  19. (define (node-fv-set! x y)       (vector-set! x 3 y))
  20. (define (node-decl-set! x y)     (vector-set! x 4 y))
  21. (define (node-source-set! x y)   (vector-set! x 5 y))
  22.  
  23. (define (node-children-set! x y)
  24.   (vector-set! x 2 y)
  25.   (for-each (lambda (child) (node-parent-set! child x)) y)
  26.   (node-fv-invalidate! x))
  27.  
  28. (define (node-fv-invalidate! x)
  29.   (let loop ((node x))
  30.     (if node
  31.       (begin
  32.         (node-fv-set! node #t)
  33.         (loop (node-parent node))))))
  34.  
  35. (define (make-cst ; node that represents constants
  36.          parent children fv decl source ; common to all nodes
  37.  
  38.     val) ; value of the constant
  39.  
  40.   (vector cst-tag parent children fv decl source val))
  41.  
  42. (define (cst? x)
  43.   (and (vector? x)
  44.        (> (vector-length x) 0)
  45.        (eq? (vector-ref x 0) cst-tag)))
  46.  
  47. (define (cst-val x)        (vector-ref x 6))
  48. (define (cst-val-set! x y) (vector-set! x 6 y))
  49.  
  50. (define cst-tag (list 'cst-tag))
  51.  
  52. (define (make-ref ; node that represents variable references
  53.          parent children fv decl source ; common to all nodes
  54.  
  55.     var) ; the variable which is referenced
  56.  
  57.   (vector ref-tag parent children fv decl source var))
  58.  
  59. (define (ref? x)
  60.   (and (vector? x)
  61.        (> (vector-length x) 0)
  62.        (eq? (vector-ref x 0) ref-tag)))
  63.  
  64. (define (ref-var x)        (vector-ref x 6))
  65. (define (ref-var-set! x y) (vector-set! x 6 y))
  66.  
  67. (define ref-tag (list 'ref-tag))
  68.  
  69. (define (make-set ; node that represents assignments (i.e. set! special forms)
  70.          parent children fv decl source ; common to all nodes
  71.  
  72.     var) ; the variable which is assigned a value
  73.  
  74.   (vector set-tag parent children fv decl source var))
  75.  
  76. (define (set? x)
  77.   (and (vector? x)
  78.        (> (vector-length x) 0)
  79.        (eq? (vector-ref x 0) set-tag)))
  80.  
  81. (define (set-var x)        (vector-ref x 6))
  82. (define (set-var-set! x y) (vector-set! x 6 y))
  83.  
  84. (define set-tag (list 'set-tag))
  85.  
  86. (define (make-def ; node that represents toplevel definitions
  87.          parent children fv decl source ; common to all nodes
  88.  
  89.     var) ; the global variable which is assigned a value
  90.  
  91.   (vector def-tag parent children fv decl source var))
  92.  
  93. (define (def? x)
  94.   (and (vector? x)
  95.        (> (vector-length x) 0)
  96.        (eq? (vector-ref x 0) def-tag)))
  97.  
  98. (define (def-var x)        (vector-ref x 6))
  99. (define (def-var-set! x y) (vector-set! x 6 y))
  100.  
  101. (define def-tag (list 'def-tag))
  102.  
  103. (define (make-tst ; node that represents conditionals (i.e. if special forms)
  104.          parent children fv decl source ; common to all nodes
  105.  
  106.     )
  107.  
  108.   (vector tst-tag parent children fv decl source))
  109.  
  110. (define (tst? x)
  111.   (and (vector? x)
  112.        (> (vector-length x) 0)
  113.        (eq? (vector-ref x 0) tst-tag)))
  114.  
  115. (define tst-tag (list 'tst-tag))
  116.  
  117. (define (make-conj ; node that represents conjunctions (i.e. and special forms)
  118.          parent children fv decl source ; common to all nodes
  119.  
  120.     )
  121.  
  122.   (vector conj-tag parent children fv decl source))
  123.  
  124. (define (conj? x)
  125.   (and (vector? x)
  126.        (> (vector-length x) 0)
  127.        (eq? (vector-ref x 0) conj-tag)))
  128.  
  129. (define conj-tag (list 'conj-tag))
  130.  
  131. (define (make-disj ; node that represents disjunctions (i.e. or special forms)
  132.          parent children fv decl source ; common to all nodes
  133.  
  134.     )
  135.  
  136.   (vector disj-tag parent children fv decl source))
  137.  
  138. (define (disj? x)
  139.   (and (vector? x)
  140.        (> (vector-length x) 0)
  141.        (eq? (vector-ref x 0) disj-tag)))
  142.  
  143. (define disj-tag (list 'disj-tag))
  144.  
  145. (define (make-prc ; node that represents procedures (i.e. lambda-expressions)
  146.          parent children fv decl source ; common to all nodes
  147.  
  148.     name   ; name of this procedure (string)
  149.     min    ; number of required parameters
  150.     rest   ; #t if the last parameter is a rest parameter
  151.     parms) ; the list of parameter variables in order
  152.  
  153.   (vector prc-tag parent children fv decl source name min rest parms))
  154.  
  155. (define (prc? x)
  156.   (and (vector? x)
  157.        (> (vector-length x) 0)
  158.        (eq? (vector-ref x 0) prc-tag)))
  159.  
  160. (define (prc-name x)         (vector-ref x 6))
  161. (define (prc-min x)          (vector-ref x 7))
  162. (define (prc-rest x)         (vector-ref x 8))
  163. (define (prc-parms x)        (vector-ref x 9))
  164. (define (prc-name-set! x y)  (vector-set! x 6 y))
  165. (define (prc-min-set! x y)   (vector-set! x 7 y))
  166. (define (prc-rest-set! x y)  (vector-set! x 8 y))
  167. (define (prc-parms-set! x y) (vector-set! x 9 y))
  168.  
  169. (define prc-tag (list 'prc-tag))
  170.  
  171. (define (make-app ; node that represents procedure calls
  172.          parent children fv decl source ; common to all nodes
  173.  
  174.     )
  175.  
  176.   (vector app-tag parent children fv decl source))
  177.  
  178. (define (app? x)
  179.   (and (vector? x)
  180.        (> (vector-length x) 0)
  181.        (eq? (vector-ref x 0) app-tag)))
  182.  
  183. (define app-tag (list 'app-tag))
  184.  
  185. (define (make-fut ; node that represents future constructs
  186.          parent children fv decl source ; common to all nodes
  187.  
  188.     )
  189.  
  190.   (vector fut-tag parent children fv decl source))
  191.  
  192. (define (fut? x)
  193.   (and (vector? x)
  194.        (> (vector-length x) 0)
  195.        (eq? (vector-ref x 0) fut-tag)))
  196.  
  197. (define fut-tag (list 'fut-tag))
  198.  
  199. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  200. ;
  201. ; Procedures to create parse tree nodes and extract sub-nodes.
  202.  
  203. (define (new-cst source decl val)
  204.   (make-cst #f '() #t decl source val))
  205.  
  206. (define (new-ref source decl var)
  207.   (let ((node (make-ref #f '() #t decl source var)))
  208.     (var-refs-set! var (set-adjoin (var-refs var) node))
  209.     node))
  210.  
  211. (define (new-ref-extended-bindings source name env)
  212.   (new-ref source
  213.            (add-extended-bindings (env-declarations env))
  214.            (env-lookup-global-var env name)))
  215.  
  216. (define (new-set source decl var val)
  217.   (let ((node (make-set #f (list val) #t decl source var)))
  218.     (var-sets-set! var (set-adjoin (var-sets var) node))
  219.     (node-parent-set! val node)
  220.     node))
  221.  
  222. (define (set-val x)
  223.   (if (set? x)
  224.     (car (node-children x))
  225.     (compiler-internal-error "set-val, 'set' node expected" x)))
  226.  
  227. (define (new-def source decl var val)
  228.   (let ((node (make-def #f (list val) #t decl source var)))
  229.     (var-sets-set! var (set-adjoin (var-sets var) node))
  230.     (node-parent-set! val node)
  231.     node))
  232.  
  233. (define (def-val x)
  234.   (if (def? x)
  235.     (car (node-children x))
  236.     (compiler-internal-error "def-val, 'def' node expected" x)))
  237.  
  238. (define (new-tst source decl pre con alt)
  239.   (let ((node (make-tst #f (list pre con alt) #t decl source)))
  240.     (node-parent-set! pre node)
  241.     (node-parent-set! con node)
  242.     (node-parent-set! alt node)
  243.     node))
  244.  
  245. (define (tst-pre x)
  246.   (if (tst? x)
  247.     (car (node-children x))
  248.     (compiler-internal-error "tst-pre, 'tst' node expected" x)))
  249.  
  250. (define (tst-con x)
  251.   (if (tst? x)
  252.     (cadr (node-children x))
  253.     (compiler-internal-error "tst-con, 'tst' node expected" x)))
  254.  
  255. (define (tst-alt x)
  256.   (if (tst? x)
  257.     (caddr (node-children x))
  258.     (compiler-internal-error "tst-alt, 'tst' node expected" x)))
  259.  
  260. (define (new-conj source decl pre alt)
  261.   (let ((node (make-conj #f (list pre alt) #t decl source)))
  262.     (node-parent-set! pre node)
  263.     (node-parent-set! alt node)
  264.     node))
  265.  
  266. (define (conj-pre x)
  267.   (if (conj? x)
  268.     (car (node-children x))
  269.     (compiler-internal-error "conj-pre, 'conj' node expected" x)))
  270.  
  271. (define (conj-alt x)
  272.   (if (conj? x)
  273.     (cadr (node-children x))
  274.     (compiler-internal-error "conj-alt, 'conj' node expected" x)))
  275.  
  276. (define (new-disj source decl pre alt)
  277.   (let ((node (make-disj #f (list pre alt) #t decl source)))
  278.     (node-parent-set! pre node)
  279.     (node-parent-set! alt node)
  280.     node))
  281.  
  282. (define (disj-pre x)
  283.   (if (disj? x)
  284.     (car (node-children x))
  285.     (compiler-internal-error "disj-pre, 'disj' node expected" x)))
  286.  
  287. (define (disj-alt x)
  288.   (if (disj? x)
  289.     (cadr (node-children x))
  290.     (compiler-internal-error "disj-alt, 'disj' node expected" x)))
  291.  
  292. (define (new-prc source decl name min rest parms body)
  293.   (let ((node (make-prc #f (list body) #t decl source name min rest parms)))
  294.     (for-each (lambda (x) (var-bound-set! x node)) parms)
  295.     (node-parent-set! body node)
  296.     node))
  297.  
  298. (define (prc-body x)
  299.   (if (prc? x)
  300.     (car (node-children x))
  301.     (compiler-internal-error "prc-body, 'proc' node expected" x)))
  302.  
  303. (define (new-call source decl oper args)
  304.   (let ((node (make-app #f (cons oper args) #t decl source)))
  305.     (node-parent-set! oper node)
  306.     (for-each (lambda (x) (node-parent-set! x node)) args)
  307.     node))
  308.  
  309. (define (new-call* source decl oper args)
  310.   (if *ptree-port*
  311.     (if (ref? oper)
  312.       (let ((var (ref-var oper)))
  313.         (if (global? var)
  314.           (let ((proc (standard-procedure (var-name var) (node-decl oper))))
  315.             (if (and proc
  316.                      (not (nb-args-conforms?
  317.                             (length args)
  318.                             (standard-procedure-call-pattern proc))))
  319.               (begin
  320.                 (display "*** Warning: \"" *ptree-port*)
  321.                 (display (var-name var) *ptree-port*)
  322.                 (display "\" is called with " *ptree-port*)
  323.                 (display (length args) *ptree-port*)
  324.                 (display " argument(s)." *ptree-port*)
  325.                 (newline *ptree-port*))))))))
  326.   (new-call source decl oper args))
  327.  
  328. (define (app-oper x)
  329.   (if (app? x)
  330.     (car (node-children x))
  331.     (compiler-internal-error "app-oper, 'call' node expected" x)))
  332.  
  333. (define (app-args x)
  334.   (if (app? x)
  335.     (cdr (node-children x))
  336.     (compiler-internal-error "app-args, 'call' node expected" x)))
  337.  
  338. (define (oper-pos? node)
  339.   (let ((parent (node-parent node)))
  340.     (if parent
  341.       (and (app? parent)
  342.            (eq? (app-oper parent) node))
  343.       #f)))
  344.  
  345. (define (new-fut source decl val)
  346.   (let ((node (make-fut #f (list val) #t decl source)))
  347.     (node-parent-set! val node)
  348.     node))
  349.  
  350. (define (fut-val x)
  351.   (if (fut? x)
  352.     (car (node-children x))
  353.     (compiler-internal-error "fut-val, 'fut' node expected" x)))
  354.  
  355. (define (new-disj-call source decl pre oper alt)
  356.   (new-call* source decl
  357.     (let* ((parms (new-temps source '(temp)))
  358.            (temp (car parms)))
  359.       (new-prc source decl #f 1 #f parms
  360.         (new-tst source decl
  361.           (new-ref source decl temp)
  362.           (new-call* source decl oper (list (new-ref source decl temp)))
  363.           alt)))
  364.     (list pre)))
  365.  
  366. (define (new-seq source decl before after)
  367.   (new-call* source decl
  368.     (new-prc source decl #f 1 #f (new-temps source '(temp))
  369.       after)
  370.     (list before)))
  371.  
  372. (define (new-let ptree proc vars vals body)
  373.   (if (pair? vars)
  374.     (new-call (node-source ptree) (node-decl ptree)
  375.       (new-prc (node-source proc) (node-decl proc)
  376.         (prc-name proc)
  377.         (length vars)
  378.         #f
  379.         (reverse vars)
  380.         body)
  381.       (reverse vals))
  382.     body))
  383.  
  384. (define (new-temps source names)
  385.   (if (null? names)
  386.     '()
  387.     (cons (make-var (car names) #t (set-empty) (set-empty) source)
  388.           (new-temps source (cdr names)))))
  389.  
  390. (define (new-variables vars)
  391.   (if (null? vars)
  392.     '()
  393.     (cons (make-var (source-code (car vars)) #t (set-empty) (set-empty) (car vars))
  394.           (new-variables (cdr vars)))))
  395.  
  396. (define (set-prc-names! vars vals)
  397.   (let loop ((vars vars) (vals vals))
  398.     (if (not (null? vars))
  399.       (let ((var (car vars))
  400.             (val (car vals)))
  401.         (if (prc? val)
  402.           (prc-name-set! val (symbol->string (var-name var))))
  403.         (loop (cdr vars) (cdr vals))))))
  404.  
  405. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  406. ;
  407. ; Procedures to get variable classes from nodes.
  408.  
  409. (define (free-variables node) ; set of free variables used in the expression
  410.   (if (eq? (node-fv node) #t)
  411.     (let ((x (apply set-union (map free-variables (node-children node)))))
  412.       (node-fv-set! node
  413.         (cond ((ref? node)
  414.                (if (global? (ref-var node)) x (set-adjoin x (ref-var node))))
  415.               ((set? node)
  416.                (if (global? (set-var node)) x (set-adjoin x (set-var node))))
  417.               ((prc? node)
  418.                (set-difference x (list->set (prc-parms node))))
  419.               ((and (app? node) (prc? (app-oper node)))
  420.                (set-difference x (list->set (prc-parms (app-oper node)))))
  421.               (else
  422.                x)))))
  423.   (node-fv node))
  424.  
  425. (define (bound-variables node) ; set of variables bound by a procedure
  426.   (list->set (prc-parms node)))
  427.  
  428. (define (not-mutable? var)
  429.   (set-empty? (var-sets var)))
  430.  
  431. (define (mutable? var)
  432.   (not (not-mutable? var)))
  433.  
  434. (define (bound? var)
  435.   (var-bound var))
  436.  
  437. (define (global? var)
  438.   (not (bound? var)))
  439.  
  440. (define (global-val var) ; get value of a global if it is known to be constant
  441.   (and (global? var)
  442.        (let ((sets (set->list (var-sets var))))
  443.          (and (pair? sets) (null? (cdr sets))
  444.               (def? (car sets))
  445.               (eq? (compilation-strategy (node-decl (car sets))) BLOCK-sym)
  446.               (def-val (car sets))))))
  447.  
  448. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  449. ;
  450. ; Canonical symbols for procedures needed by the front end:
  451.  
  452. (define **NOT-sym                (string->canonical-symbol "##NOT"))
  453. (define **QUASI-APPEND-sym       (string->canonical-symbol "##QUASI-APPEND"))
  454. (define **QUASI-LIST-sym         (string->canonical-symbol "##QUASI-LIST"))
  455. (define **QUASI-CONS-sym         (string->canonical-symbol "##QUASI-CONS"))
  456. (define **QUASI-LIST->VECTOR-sym (string->canonical-symbol "##QUASI-LIST->VECTOR"))
  457. (define **CASE-MEMV-sym          (string->canonical-symbol "##CASE-MEMV"))
  458. (define **UNASSIGNED?-sym        (string->canonical-symbol "##UNASSIGNED?"))
  459. (define **MAKE-CELL-sym          (string->canonical-symbol "##MAKE-CELL"))
  460. (define **CELL-REF-sym           (string->canonical-symbol "##CELL-REF"))
  461. (define **CELL-SET!-sym          (string->canonical-symbol "##CELL-SET!"))
  462.  
  463. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  464. ;
  465. ; Declarations relevant to parsing:
  466.  
  467. ; Dialect related declarations:
  468. ;
  469. ; (ieee-scheme)     use IEEE Scheme
  470. ; (r4rs-scheme)     use R4RS Scheme
  471. ; (multilisp)       use Multilisp
  472. ;
  473. ; Lambda-lifting declarations:
  474. ;
  475. ; (lambda-lift)     can lambda-lift procedures
  476. ; (not lambda-lift) can't lambda-lift procedures
  477. ;
  478. ; Compilation strategy declarations:
  479. ;
  480. ; (block)     global vars defined are only mutated by code in the current file
  481. ; (separate)  global vars defined can be mutated by other code
  482. ;
  483. ; Global variable binding declarations:
  484. ;
  485. ; (standard-bindings)                 compiler can assume standard bindings
  486. ; (standard-bindings <var1> ...)      assume st. bind. for vars specified
  487. ; (not standard-bindings)             can't assume st. bind. for any var
  488. ; (not standard-bindings <var1> ...)  can't assume st. bind. for vars spec.
  489. ;
  490. ; (extended-bindings)                 compiler can assume extended bindings
  491. ; (extended-bindings <var1> ...)      assume ext. bind. for vars specified
  492. ; (not extended-bindings)             can't assume ext. bind. for any var
  493. ; (not extended-bindings <var1> ...)  can't assume ext. bind. for vars spec.
  494. ;
  495. ; Code safety declarations:
  496. ;
  497. ; (safe)                              runtime errors won't crash system
  498. ; (not safe)                          assume program doesn't contain errors
  499. ;
  500. ; Interrupt checking declarations:
  501. ;
  502. ; (intr-checks)     generate interrupt checks
  503. ; (not intr-checks) don't generate interrupt checks
  504. ;
  505. ; Future implementation method declarations:
  506. ;
  507. ; (futures off)                       future = identity operation
  508. ; (futures delay)                     'delay' future method
  509. ; (futures eager)                     'eager' future method
  510. ; (futures lazy)                      'lazy' future method
  511. ; (futures eager-inline)              inlined 'eager' future method
  512. ;
  513. ; Touching analysis declarations:
  514. ;
  515. ; (autotouch)                         compiler does touching wherever needed
  516. ; (not autotouch)                     (touch ...) are explicit
  517.  
  518. (define IEEE-SCHEME-sym (string->canonical-symbol "IEEE-SCHEME"))
  519. (define R4RS-SCHEME-sym (string->canonical-symbol "R4RS-SCHEME"))
  520. (define MULTILISP-sym   (string->canonical-symbol "MULTILISP"))
  521.  
  522. (define LAMBDA-LIFT-sym (string->canonical-symbol "LAMBDA-LIFT"))
  523.  
  524. (define BLOCK-sym       (string->canonical-symbol "BLOCK"))
  525. (define SEPARATE-sym    (string->canonical-symbol "SEPARATE"))
  526.  
  527. (define STANDARD-BINDINGS-sym (string->canonical-symbol "STANDARD-BINDINGS"))
  528. (define EXTENDED-BINDINGS-sym (string->canonical-symbol "EXTENDED-BINDINGS"))
  529.  
  530. (define SAFE-sym              (string->canonical-symbol "SAFE"))
  531.  
  532. (define INTR-CHECKS-sym       (string->canonical-symbol "INTR-CHECKS"))
  533.  
  534. (define FUTURES-sym           (string->canonical-symbol "FUTURES"))
  535. (define OFF-sym               (string->canonical-symbol "OFF"))
  536. (define LAZY-sym              (string->canonical-symbol "LAZY"))
  537. (define EAGER-sym             (string->canonical-symbol "EAGER"))
  538. (define EAGER-INLINE-sym      (string->canonical-symbol "EAGER-INLINE"))
  539.  
  540. (define AUTOTOUCH-sym         (string->canonical-symbol "AUTOTOUCH"))
  541.  
  542. (define-flag-decl IEEE-SCHEME-sym 'dialect)
  543. (define-flag-decl R4RS-SCHEME-sym 'dialect)
  544. (define-flag-decl MULTILISP-sym   'dialect)
  545.  
  546. (define-boolean-decl LAMBDA-LIFT-sym)
  547.  
  548. (define-flag-decl BLOCK-sym    'compilation-strategy)
  549. (define-flag-decl SEPARATE-sym 'compilation-strategy)
  550.  
  551. (define-namable-boolean-decl STANDARD-BINDINGS-sym)
  552. (define-namable-boolean-decl EXTENDED-BINDINGS-sym)
  553.  
  554. (define-boolean-decl SAFE-sym)
  555.  
  556. (define-boolean-decl INTR-CHECKS-sym)
  557.  
  558. (define-parameterized-decl FUTURES-sym)
  559.  
  560. (define-boolean-decl AUTOTOUCH-sym)
  561.  
  562. (define (scheme-dialect decl) ; returns dialect in effect
  563.   (declaration-value 'dialect #f IEEE-SCHEME-sym decl))
  564.  
  565. (define (lambda-lift? decl) ; true iff should lambda-lift
  566.   (declaration-value LAMBDA-LIFT-sym #f #t decl))
  567.  
  568. (define (compilation-strategy decl) ; returns compilation strategy in effect
  569.   (declaration-value 'compilation-strategy #f SEPARATE-sym decl))
  570.  
  571. (define (standard-binding? name decl) ; true iff name's binding is standard
  572.   (declaration-value STANDARD-BINDINGS-sym name #f decl))
  573.  
  574. (define (extended-binding? name decl) ; true iff name's binding is extended
  575.   (declaration-value EXTENDED-BINDINGS-sym name #f decl))
  576.  
  577. (define (add-extended-bindings decl)
  578.   (add-decl (list EXTENDED-BINDINGS-sym #t) decl))
  579.  
  580. (define (intr-checks? decl) ; true iff system should generate interrupt checks
  581.   (declaration-value INTR-CHECKS-sym #f #t decl))
  582.  
  583. (define (futures-method decl) ; returns type of future implementation method
  584.   (declaration-value FUTURES-sym #f LAZY-sym decl))
  585.  
  586. (define (add-delay decl)
  587.   (add-decl (list FUTURES-sym DELAY-sym) decl))
  588.  
  589. (define (autotouch? decl) ; true iff autotouching (default depends on dialect)
  590.   (declaration-value AUTOTOUCH-sym
  591.                      #f
  592.                      (eq? (scheme-dialect decl) MULTILISP-sym)
  593.                      decl))
  594.  
  595. (define (safe? decl) ; true iff system should prevent fatal runtime errors
  596.   (declaration-value SAFE-sym #f #f decl))
  597.  
  598. (define (add-not-safe decl)
  599.   (add-decl (list SAFE-sym #f) decl))
  600.  
  601. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  602. ;
  603. ; Dialect info:
  604.  
  605. (define (dialect-specific-keywords dialect)
  606.   (cond ((eq? dialect IEEE-SCHEME-sym)
  607.          ieee-scheme-specific-keywords)
  608.         ((eq? dialect R4RS-SCHEME-sym)
  609.          r4rs-scheme-specific-keywords)
  610.         ((eq? dialect MULTILISP-sym)
  611.          multilisp-specific-keywords)
  612.         (else
  613.          (compiler-internal-error
  614.            "dialect-specific-keywords, unknown dialect" dialect))))
  615.  
  616. (define (dialect-specific-procedures dialect)
  617.   (cond ((eq? dialect IEEE-SCHEME-sym)
  618.          ieee-scheme-specific-procedures)
  619.         ((eq? dialect R4RS-SCHEME-sym)
  620.          r4rs-scheme-specific-procedures)
  621.         ((eq? dialect MULTILISP-sym)
  622.          multilisp-specific-procedures)
  623.         (else
  624.          (compiler-internal-error
  625.            "dialect-specific-procedures, unknown dialect" dialect))))
  626.  
  627. (define (make-standard-procedure x)
  628.   (cons (string->canonical-symbol (car x)) (cdr x)))
  629.  
  630. (define (standard-procedure name decl)
  631.   (or (assq name (dialect-specific-procedures (scheme-dialect decl)))
  632.       (assq name common-procedures)))
  633.  
  634. (define (standard-procedure-call-pattern proc)
  635.   (cdr proc))
  636.  
  637. ; IEEE Scheme
  638.  
  639. (define ieee-scheme-specific-keywords
  640.   '())
  641.  
  642. (define ieee-scheme-specific-procedures (map make-standard-procedure '(
  643.  
  644. )))
  645.  
  646. ; R4RS Scheme
  647.  
  648. (define r4rs-scheme-specific-keywords
  649.   (list DELAY-sym))
  650.  
  651. (define r4rs-scheme-specific-procedures (map make-standard-procedure '(
  652.  
  653. ; section 6.3
  654.  
  655. ("LIST-TAIL" 2)
  656.  
  657. ; section 6.5
  658.  
  659. ("-" . 1) ("/" . 1)
  660.  
  661. ; section 6.7
  662.  
  663. ("STRING->LIST" 1) ("LIST->STRING" 1) ("STRING-COPY" 1) ("STRING-FILL!" 2)
  664.  
  665. ; section 6.8
  666.  
  667. ("VECTOR->LIST" 1) ("LIST->VECTOR" 1) ("VECTOR-FILL!" 2)
  668.  
  669. ; section 6.9
  670.  
  671. ("FORCE" 1)
  672.  
  673. ; section 6.10
  674.  
  675. ("WITH-INPUT-FROM-FILE" 2) ("WITH-OUTPUT-TO-FILE" 2) ("CHAR-READY?" 0 1)
  676. ("LOAD" 1) ("TRANSCRIPT-ON" 1) ("TRANSCRIPT-OFF" 0)
  677.  
  678. )))
  679.  
  680. ; Multilisp
  681.  
  682. (define multilisp-specific-keywords
  683.   (list DELAY-sym FUTURE-sym))
  684.  
  685. (define multilisp-specific-procedures (map make-standard-procedure '(
  686.  
  687. ("FORCE" 1)
  688. ("TOUCH" 1)
  689.  
  690. )))
  691.  
  692. ; common stuff
  693.  
  694. (define common-keywords
  695.   (list QUOTE-sym QUASIQUOTE-sym UNQUOTE-sym UNQUOTE-SPLICING-sym
  696.         LAMBDA-sym IF-sym SET!-sym COND-sym =>-sym ELSE-sym AND-sym OR-sym
  697.         CASE-sym LET-sym LET*-sym LETREC-sym BEGIN-sym DO-sym DEFINE-sym
  698.         **DEFINE-MACRO-sym **DECLARE-sym **INCLUDE-sym))
  699.  
  700. (define common-procedures (map make-standard-procedure '(
  701.  
  702. ; taken from IEEE Scheme standard draft P1178/D4
  703.  
  704. ; section 6.1
  705.  
  706. ("NOT" 1) ("BOOLEAN?" 1)
  707.  
  708. ; section 6.2
  709.  
  710. ("EQV?" 2) ("EQ?" 2) ("EQUAL?" 2)
  711.  
  712. ; section 6.3
  713.  
  714. ("PAIR?" 1) ("CONS" 2) ("CAR" 1) ("CDR" 1) ("SET-CAR!" 2) ("SET-CDR!" 2)
  715. ("CAAR" 1) ("CADR" 1) ("CDAR" 1) ("CDDR" 1) ("CAAAR" 1) ("CAADR" 1)
  716. ("CADAR" 1) ("CADDR" 1) ("CDAAR" 1) ("CDADR" 1) ("CDDAR" 1) ("CDDDR" 1)
  717. ("CAAAAR" 1) ("CAAADR" 1) ("CAADAR" 1) ("CAADDR" 1) ("CADAAR" 1)
  718. ("CADADR" 1) ("CADDAR" 1) ("CADDDR" 1) ("CDAAAR" 1) ("CDAADR" 1)
  719. ("CDADAR" 1) ("CDADDR" 1) ("CDDAAR" 1) ("CDDADR" 1) ("CDDDAR" 1)
  720. ("CDDDDR" 1) ("NULL?" 1) ("LIST?" 1) ("LIST" . 0) ("LENGTH" 1)
  721. ("APPEND" . 0) ("REVERSE" 1) ("LIST-REF" 2) ("MEMQ" 2) ("MEMV" 2)
  722. ("MEMBER" 2) ("ASSQ" 2) ("ASSV" 2) ("ASSOC" 2)
  723.  
  724. ; section 6.4
  725.  
  726. ("SYMBOL?" 1) ("SYMBOL->STRING" 1) ("STRING->SYMBOL" 1)
  727.  
  728. ; section 6.5
  729.  
  730. ("NUMBER?" 1) ("COMPLEX?" 1) ("REAL?" 1) ("RATIONAL?" 1) ("INTEGER?" 1)
  731. ("EXACT?" 1) ("INEXACT?" 1) ("=" . 2) ("<" . 2) (">" . 2) ("<=" . 2)
  732. (">=" . 2) ("ZERO?" 1) ("POSITIVE?" 1) ("NEGATIVE?" 1) ("ODD?" 1) ("EVEN?" 1)
  733. ("MAX" . 1) ("MIN" . 1) ("+" . 0) ("*" . 0) ("-" 1 2) ("/" 1 2) ("ABS" 1)
  734. ("QUOTIENT" 2) ("REMAINDER" 2) ("MODULO" 2) ("GCD" . 0) ("LCM" . 0)
  735. ("NUMERATOR" 1) ("DENOMINATOR" 1) ("FLOOR" 1) ("CEILING" 1)
  736. ("TRUNCATE" 1) ("ROUND" 1) ("RATIONALIZE" 2) ("EXP" 1) ("LOG" 1)
  737. ("SIN" 1) ("COS" 1) ("TAN" 1) ("ASIN" 1) ("ACOS" 1) ("ATAN" 1 2) ("SQRT" 1)
  738. ("EXPT" 2) ("MAKE-RECTANGULAR" 2) ("MAKE-POLAR" 2) ("REAL-PART" 1)
  739. ("IMAG-PART" 1) ("MAGNITUDE" 1) ("ANGLE" 1) ("EXACT->INEXACT" 1)
  740. ("INEXACT->EXACT" 1) ("NUMBER->STRING" 1 2) ("STRING->NUMBER" 1 2)
  741.  
  742. ; section 6.6
  743.  
  744. ("CHAR?" 1) ("CHAR=?" 2) ("CHAR<?" 2) ("CHAR>?" 2) ("CHAR<=?" 2)
  745. ("CHAR>=?" 2) ("CHAR-CI=?" 2) ("CHAR-CI<?" 2) ("CHAR-CI>?" 2)
  746. ("CHAR-CI<=?" 2) ("CHAR-CI>=?" 2) ("CHAR-ALPHABETIC?" 1)
  747. ("CHAR-NUMERIC?" 1) ("CHAR-WHITESPACE?" 1) ("CHAR-UPPER-CASE?" 1)
  748. ("CHAR-LOWER-CASE?" 1) ("CHAR->INTEGER" 1) ("INTEGER->CHAR" 1)
  749. ("CHAR-UPCASE" 1) ("CHAR-DOWNCASE" 1)
  750.  
  751. ; section 6.7
  752.  
  753. ("STRING?" 1) ("MAKE-STRING" 1 2) ("STRING" . 0) ("STRING-LENGTH" 1)
  754. ("STRING-REF" 2) ("STRING-SET!" 3) ("STRING=?" 2) ("STRING<?" 2)
  755. ("STRING>?" 2) ("STRING<=?" 2) ("STRING>=?" 2) ("STRING-CI=?" 2)
  756. ("STRING-CI<?" 2) ("STRING-CI>?" 2) ("STRING-CI<=?" 2) ("STRING-CI>=?" 2)
  757. ("SUBSTRING" 3) ("STRING-APPEND" . 0)
  758.  
  759. ; section 6.8
  760.  
  761. ("VECTOR?" 1) ("MAKE-VECTOR" 1 2) ("VECTOR" . 0) ("VECTOR-LENGTH" 1)
  762. ("VECTOR-REF" 2) ("VECTOR-SET!" 3)
  763.  
  764. ; section 6.9
  765.  
  766. ("PROCEDURE?" 1) ("APPLY" . 2) ("MAP" . 2) ("FOR-EACH" . 2)
  767. ("CALL-WITH-CURRENT-CONTINUATION" 1)
  768.  
  769. ; section 6.10
  770.  
  771. ("CALL-WITH-INPUT-FILE" 2) ("CALL-WITH-OUTPUT-FILE" 2) ("INPUT-PORT?" 1)
  772. ("OUTPUT-PORT?" 1) ("CURRENT-INPUT-PORT" 0) ("CURRENT-OUTPUT-PORT" 0)
  773. ("OPEN-INPUT-FILE" 1) ("OPEN-OUTPUT-FILE" 1) ("CLOSE-INPUT-PORT" 1)
  774. ("CLOSE-OUTPUT-PORT" 1) ("EOF-OBJECT?" 1) ("READ" 0 1) ("READ-CHAR" 0 1)
  775. ("PEEK-CHAR" 0 1) ("WRITE" 1 2) ("DISPLAY" 1 2) ("NEWLINE" 0 1)
  776. ("WRITE-CHAR" 1 2)
  777.  
  778. )))
  779.  
  780. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  781. ;
  782. ; (parse-program program env proc) returns a list of parse trees/environment
  783. ; pairs describing the program and the final global environment.
  784.  
  785. (define (parse-program program env proc)
  786.  
  787.   (if *ptree-port*
  788.     (begin
  789.       (display "Parsing:" *ptree-port*)
  790.       (newline *ptree-port*)))
  791.  
  792.   (parse-prog program env '()
  793.     (lambda (lst env)
  794.  
  795.       (if *ptree-port*
  796.         (newline *ptree-port*))
  797.  
  798.       (proc lst env))))
  799.  
  800. (define (parse-prog program env lst proc)
  801.   (if (null? program)
  802.     (proc (reverse lst) env)
  803.     (let ((source (car program)))
  804.  
  805.       (cond ((macro-expr? source env)
  806.              (parse-prog
  807.                (cons (macro-expand source env) (cdr program))
  808.                env
  809.                lst
  810.                proc))
  811.  
  812.             ((begin-defs-expr? source)
  813.              (parse-prog
  814.                (append (begin-defs-body source) (cdr program))
  815.                env
  816.                lst
  817.                proc))
  818.  
  819.             ((include-expr? source)
  820.  
  821.              (if *ptree-port*
  822.                (display "  " *ptree-port*))
  823.  
  824.              (let ((x (file->sources* (include-filename source)
  825.                                       *ptree-port*
  826.                                       (source-locat source))))
  827.  
  828.                (if *ptree-port*
  829.                  (newline *ptree-port*))
  830.                       
  831.                (parse-prog
  832.                  (append x (cdr program))
  833.                  env
  834.                  lst
  835.                  proc)))
  836.  
  837.             ((define-macro-expr? source env)
  838.  
  839.              (if *ptree-port*
  840.                (begin
  841.                  (display "  \"macro\"" *ptree-port*)
  842.                  (newline *ptree-port*)))
  843.  
  844.              (parse-prog
  845.                (cdr program)
  846.                (add-macro source env)
  847.                lst
  848.                proc))
  849.  
  850.             ((declare-expr? source)
  851.  
  852.              (if *ptree-port*
  853.                (begin
  854.                  (display "  \"decl\"" *ptree-port*)
  855.                  (newline *ptree-port*)))
  856.  
  857.              (parse-prog
  858.                (cdr program)
  859.                (add-declarations source env)
  860.                lst
  861.                proc))
  862.  
  863.             ((define-expr? source env)
  864.              (let* ((var** (definition-variable source))
  865.                     (var* (source-code var**))
  866.                     (var (env-lookup-var env var* var**)))
  867.  
  868.                (if *ptree-port*
  869.                  (begin
  870.                    (display "  " *ptree-port*)
  871.                    (display (var-name var) *ptree-port*)
  872.                    (newline *ptree-port*)))
  873.  
  874.                (let ((node (pt (definition-value source) env 'TRUE)))
  875.                  (set-prc-names! (list var) (list node))
  876.                  (parse-prog
  877.                    (cdr program)
  878.                    env
  879.                    (cons (cons (new-def source (env-declarations env) var node) env) lst)
  880.                    proc))))
  881.  
  882.             (else
  883.  
  884.              (if *ptree-port*
  885.                (begin
  886.                  (display "  \"expr\"" *ptree-port*)
  887.                  (newline *ptree-port*)))
  888.  
  889.              (parse-prog
  890.                (cdr program)
  891.                env
  892.                (cons (cons (pt source env 'TRUE) env) lst)
  893.                proc))))))
  894.  
  895. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  896. ;
  897. ; (pt source env use) returns the parse tree for the Scheme source expression
  898. ; 'source' in the environment 'env'.  If 'source' is not syntactically
  899. ; correct, an error is signaled.  The value of 'use' determines what the
  900. ; expression's value will be used for; it must be one of the following:
  901. ;
  902. ;  TRUE  : the true value of the expression is needed
  903. ;  PRED  : the value is used as a predicate
  904. ;  NONE  : the value is not needed (but its side effect might)
  905.  
  906. (define (pt-syntax-error source msg . args)
  907.   (apply compiler-user-error
  908.          (cons (source-locat source)
  909.                (cons (string-append "Syntax error -- " msg)
  910.                      args))))
  911.  
  912. (define (pt source env use)
  913.   (cond ((macro-expr? source env)        (pt (macro-expand source env) env use))
  914.         ((self-eval-expr? source)        (pt-self-eval source env use))
  915.         ((quote-expr? source)            (pt-quote source env use))
  916.         ((quasiquote-expr? source)       (pt-quasiquote source env use))
  917.         ((unquote-expr? source)
  918.          (pt-syntax-error source "Ill-placed 'unquote'"))
  919.         ((unquote-splicing-expr? source)
  920.          (pt-syntax-error source "Ill-placed 'unquote-splicing'"))
  921.         ((var-expr? source env)          (pt-var source env use))
  922.         ((set!-expr? source env)         (pt-set! source env use))
  923.         ((lambda-expr? source env)       (pt-lambda source env use))
  924.         ((if-expr? source)               (pt-if source env use))
  925.         ((cond-expr? source)             (pt-cond source env use))
  926.         ((and-expr? source)              (pt-and source env use))
  927.         ((or-expr? source)               (pt-or source env use))
  928.         ((case-expr? source)             (pt-case source env use))
  929.         ((let-expr? source env)          (pt-let source env use))
  930.         ((let*-expr? source env)         (pt-let* source env use))
  931.         ((letrec-expr? source env)       (pt-letrec source env use))
  932.         ((begin-expr? source)            (pt-begin source env use))
  933.         ((do-expr? source env)           (pt-do source env use))
  934.         ((define-expr? source env)
  935.          (pt-syntax-error source "Ill-placed 'define'"))
  936.         ((delay-expr? source env)        (pt-delay source env use))
  937.         ((future-expr? source env)       (pt-future source env use))
  938.         ((define-macro-expr? source env)
  939.          (pt-syntax-error source "Ill-placed '##define-macro'"))
  940.         ((begin-defs-expr? source)
  941.          (pt-syntax-error source "Ill-placed 'begin' style definitions"))
  942.         ((declare-expr? source)
  943.          (pt-syntax-error source "Ill-placed '##declare'"))
  944.         ((combination-expr? source)      (pt-combination source env use))
  945.         (else
  946.          (compiler-internal-error "pt, unknown expression type" source))))
  947.  
  948. (define (macro-expand source env)
  949.   (let ((code (source-code source)))
  950.     (expression->source
  951.       (apply (cdr (env-lookup-macro env (source-code (car code))))
  952.              (cdr (source->expression source)))
  953.       source)))
  954.  
  955. (define (pt-self-eval source env use)
  956.   (let ((val (source->expression source)))
  957.     (if (eq? use 'NONE)
  958.       (new-cst source (env-declarations env) undef-object)
  959.       (new-cst source (env-declarations env) val))))
  960.  
  961. (define (pt-quote source env use)
  962.   (let ((code (source-code source)))
  963.     (if (eq? use 'NONE)
  964.       (new-cst source (env-declarations env) undef-object)
  965.       (new-cst source (env-declarations env) (source->expression (cadr code))))))
  966.  
  967. (define (pt-quasiquote source env use)
  968.   (let ((code (source-code source)))
  969.     (pt-quasiquotation (cadr code) 1 env)))
  970.  
  971. (define (pt-quasiquotation form level env)
  972.   (cond ((= level 0)
  973.          (pt form env 'TRUE))
  974.         ((quasiquote-expr? form)
  975.          (pt-quasiquotation-list form (source-code form) (+ level 1) env))
  976.         ((unquote-expr? form)
  977.          (if (= level 1)
  978.            (pt (cadr (source-code form)) env 'TRUE)
  979.            (pt-quasiquotation-list form (source-code form) (- level 1) env)))
  980.         ((unquote-splicing-expr? form)
  981.          (if (= level 1)
  982.            (pt-syntax-error form "Ill-placed 'unquote-splicing'")
  983.            (pt-quasiquotation-list form (source-code form) (- level 1) env)))
  984.         ((pair? (source-code form))
  985.          (pt-quasiquotation-list form (source-code form) level env))
  986.         ((vector? (source-code form))
  987.          (vector-form
  988.            form
  989.            (pt-quasiquotation-list form (vector->lst (source-code form)) level env)
  990.            env))
  991.         (else
  992.          (new-cst form (env-declarations env) (source->expression form)))))
  993.  
  994. (define (pt-quasiquotation-list form l level env)
  995.   (cond ((pair? l)
  996.          (if (and (unquote-splicing-expr? (car l)) (= level 1))
  997.            (let ((x (pt (cadr (source             (env-lookup-var env (source-code var) var))))))
  998.             (optionals (cdr parms) source body env)))
  999.         (pt-body source body env 'TRUE)))
  1000.  
  1001.     (if (eq? use 'NONE)
  1002.       (new-cst source (env-declarations env) undef-object)
  1003.       (let* ((parms (source->parms (cadr code)))
  1004.              (frame (new-params parms)))
  1005.         (new-prc source (env-declarations env)
  1006.           #f
  1007.           (min-params parms)
  1008.           (rest-param? parms)
  1009.           frame
  1010.           (optionals parms 
  1011.                      source
  1012.                      (cddr code)
  1013.                      (env-frame env frame)))))))
  1014.  
  1015. (define (source->parms source)
  1016.   (let ((x (source-code source)))
  1017.     (if (or (pair? x) (null? x)) x source)))
  1018.  
  1019. (define (pt-body source body env use)
  1020.  
  1021.   (define (letrec-defines vars vals envs body env)
  1022.     (cond ((null? body)
  1023.            (pt-syntax-error
  1024.              source
  1025.              "Body must contain at least one evaluable expression"))
  1026.           ((macro-expr? (car body) env)
  1027.            (letrec-defines vars
  1028.                            vals
  1029.                            envs
  1030.                            (cons (macro-expand (car body) env)
  1031.                                  (cdr body))
  1032.                            env))
  1033.           ((begin-defs-expr? (car body))
  1034.            (letrec-defines vars
  1035.                            vals
  1036.                            envs
  1037.                            (append (begin-defs-body (car body))
  1038.                                    (cdr body))
  1039.                            env))
  1040.           ((include-expr? (car body))
  1041.            (if *ptree-port*
  1042.              (display "  " *ptree-port*))
  1043.            (let ((x (file->sources* (include-filename (car body))
  1044.                                     *ptree-port*
  1045.                                     (source-locat (car body)))))
  1046.              (if *ptree-port*
  1047.                (newline *ptree-port*))
  1048.              (letrec-defines vars
  1049.                              vals
  1050.                              envs
  1051.                              (append x (cdr body))
  1052.                              env)))
  1053.           ((define-expr? (car body) env)
  1054.            (let* ((var** (definition-variable (car body)))
  1055.                   (var* (source-code var**))
  1056.                   (var (env-define-var env var* var**)))
  1057.              (letrec-defines (cons var vars)
  1058.                              (cons (definition-value (car body)) vals)
  1059.                              (cons env envs)
  1060.                              (cdr body)
  1061.                              env)))
  1062.           ((declare-expr? (car body))
  1063.            (letrec-defines vars
  1064.                            vals
  1065.                            envs
  1066.                            (cdr body)
  1067.                            (add-declarations (car body) env)))
  1068.           ((define-macro-expr? (car body) env)
  1069.            (letrec-defines vars
  1070.                            vals
  1071.                            envs
  1072.                            (cdr body)
  1073.                            (add-macro (car body) env)))
  1074.           ((null? vars)
  1075.            (pt-sequence source body env use))
  1076.           (else
  1077.            (let ((vars* (reverse vars)))
  1078.              (let loop ((vals* '()) (l1 vals) (l2 envs))
  1079.                (if (not (null? l1))
  1080.                  (loop (cons (pt (car l1) (car l2) 'TRUE) vals*)
  1081.                        (cdr l1)
  1082.                        (cdr l2))
  1083.                  (pt-recursive-let source vars* vals* body env use)))))))
  1084.  
  1085.   (letrec-defines '() '() '() body (env-frame env '())))
  1086.  
  1087. (define (pt-sequence source seq env use)
  1088.   (if (length? seq 1)
  1089.     (pt (car seq) env use)
  1090.     (new-seq source (env-declarations env)
  1091.       (pt (car seq) env 'NONE)
  1092.       (pt-sequence source (cdr seq) env use))))
  1093.  
  1094. (define (pt-if source env use)
  1095.   (let ((code (source-code source)))
  1096.     (new-tst source (env-declarations env)
  1097.       (pt (cadr code) env 'PRED)
  1098.       (pt (caddr code) env use)
  1099.       (if (length? code 3)
  1100.         (new-cst source (env-declarations env) undef-object)
  1101.         (pt (cadddr code) env use)))))
  1102.  
  1103. (define (pt-cond source env use)
  1104.  
  1105.   (define (pt-clauses clauses)
  1106.     (if (length? clauses 0)
  1107.       (new-cst source (env-declarations env) undef-object)
  1108.       (let* ((clause* (car clauses))
  1109.              (clause (source-code clause*)))
  1110.         (cond ((eq? (source-code (car clause)) ELSE-sym)
  1111.                (pt-sequence clause* (cdr clause) env use))
  1112.               ((length? clause 1)
  1113.                (new-disj clause* (env-declarations env)
  1114.                  (pt (car clause) env (if (eq? use 'TRUE) 'TRUE 'PRED))
  1115.                  (pt-clauses (cdr clauses))))
  1116.               ((eq? (source-code (cadr clause)) =>-sym)
  1117.                (new-disj-call clause* (env-declarations env)
  1118.                  (pt (car clause) env 'TRUE)
  1119.                  (pt (caddr clause) env 'TRUE)
  1120.                  (pt-clauses (cdr clauses))))
  1121.               (else
  1122.                (new-tst clause* (env-declarations env)
  1123.                  (pt (car clause) env 'PRED)
  1124.                  (pt-sequence clause* (cdr clause) env use)
  1125.                  (pt-clauses (cdr clauses))))))))
  1126.  
  1127.   (pt-clauses (cdr (source-code source))))
  1128.  
  1129. (define (pt-and source env use)
  1130.  
  1131.   (define (pt-exprs exprs)
  1132.     (cond ((length? exprs 0)
  1133.            (new-cst source (env-declarations env) #t))
  1134.           ((length? exprs 1)
  1135.            (pt (car exprs) env use))
  1136.           (else
  1137.            (new-conj (car exprs) (env-declarations env)
  1138.              (pt (car exprs) env (if (eq? use 'TRUE) 'TRUE 'PRED))
  1139.              (pt-exprs (cdr exprs))))))
  1140.  
  1141.   (pt-exprs (cdr (source-code source))))
  1142.  
  1143. (define (pt-or source env use)
  1144.  
  1145.   (define (pt-exprs exprs)
  1146.     (cond ((length? exprs 0)
  1147.            (new-cst source (env-declarations env) false-object))
  1148.           ((length? exprs 1)
  1149.            (pt (car exprs) env use))
  1150.           (else
  1151.            (new-disj (car exprs) (env-declarations env)
  1152.              (pt (car exprs) env (if (eq? use 'TRUE) 'TRUE 'PRED))
  1153.              (pt-exprs (cdr exprs))))))
  1154.  
  1155.   (pt-exprs (cdr (source-code source))))
  1156.  
  1157. (define (pt-case source env use)
  1158.   (let ((code (source-code source))
  1159.         (temp (new-temps source '(temp))))
  1160.  
  1161.     (define (pt-clauses clauses)
  1162.       (if (length? clauses 0)
  1163.         (new-cst source (env-declarations env) undef-object)
  1164.         (let* ((clause* (car clauses))
  1165.                (clause (source-code clause*)))
  1166.           (if (eq? (source-code (car clause)) ELSE-sym)
  1167.             (pt-sequence clause* (cdr clause) env use)
  1168.             (new-tst clause* (env-declarations env)
  1169.               (new-call* clause* (add-not-safe (env-declarations env))
  1170.                 (new-ref-extended-bindings clause* **CASE-MEMV-sym env)
  1171.                 (list (new-ref clause* (env-declarations env)
  1172.                         (car temp))
  1173.                       (new-cst (car clause) (env-declarations env)
  1174.                         (source->expression (car clause)))))
  1175.               (pt-sequence clause* (cdr clause) env use)
  1176.               (pt-clauses (cdr clauses)))))))
  1177.  
  1178.     (new-call* source (env-declarations env)
  1179.       (new-prc source (env-declarations env) #f 1 #f temp
  1180.         (pt-clauses (cddr code)))
  1181.       (list (pt (cadr code) env 'TRUE)))))
  1182.  
  1183. (define (pt-let source env use)
  1184.   (let ((code (source-code source)))
  1185.     (if (bindable-var? (cadr code) env)
  1186.       (let* ((self (new-variables (list (cadr code))))
  1187.              (bindings (map source-code (source-code (caddr code))))
  1188.              (vars (new-variables (map car bindings)))
  1189.              (vals (map (lambda (x) (pt (cadr x) env 'TRUE)) bindings))
  1190.              (env  (env-frame (env-frame env vars) self))
  1191.              (self-proc (list (new-prc source (env-declarations env)
  1192.                                 #f
  1193.                                 (length vars)
  1194.                                 #f
  1195.                                 vars
  1196.                                 (pt-body source (cdddr code) env use)))))
  1197.         (set-prc-names! self self-proc)
  1198.         (set-prc-names! vars vals)
  1199.         (new-call* source (env-declarations env)
  1200.           (new-prc source (env-declarations env) #f 1 #f self
  1201.             (new-call* source (env-declarations env)
  1202.               (new-ref source (env-declarations env) (car self))
  1203.               vals))
  1204.           self-proc))
  1205.       (if (null? (source-code (cadr code)))
  1206.         (pt-body source (cddr code) env use)
  1207.         (let* ((bindings (map source-code (source-code (cadr code))))
  1208.                (vars (new-variables (map car bindings)))
  1209.                (vals (map (lambda (x) (pt (cadr x) env 'TRUE)) bindings))
  1210.                (env  (env-frame env vars)))
  1211.           (set-prc-names! vars vals)
  1212.           (new-call* source (env-declarations env)
  1213.             (new-prc source (env-declarations env)
  1214.               #f
  1215.               (length vars)
  1216.               #f
  1217.               vars
  1218.               (pt-body source (cddr code) env use))
  1219.             vals))))))
  1220.  
  1221. (define (pt-let* source env use)
  1222.   (let ((code (source-code source)))
  1223.  
  1224.     (define (pt-bindings bindings env use)
  1225.       (if (null? bindings)
  1226.         (pt-body source (cddr code) env use)
  1227.         (let* ((binding* (car bindings))
  1228.                (binding (source-code binding*))
  1229.                (vars (new-variables (list (car binding))))
  1230.                (vals (list (pt (cadr binding) env 'TRUE)))
  1231.                (env  (env-frame env vars)))
  1232.           (set-prc-names! vars vals)
  1233.           (new-call* binding* (env-declarations env)
  1234.             (new-prc binding* (env-declarations env) #f 1 #f vars
  1235.               (pt-bindings (cdr bindings) env use))
  1236.             vals))))
  1237.  
  1238.     (pt-bindings (source-code (cadr code)) env use)))
  1239.  
  1240. (define (pt-letrec source env use)
  1241.   (let* ((code (source-code source))
  1242.          (bindings (map source-code (source-code (cadr code))))
  1243.          (vars* (new-variables (map car bindings)))
  1244.          (env*  (env-frame env vars*)))
  1245.     (pt-recursive-let
  1246.       source
  1247.       vars*
  1248.       (map (lambda (x) (pt (cadr x) env* 'TRUE)) bindings)
  1249.       (cddr code)
  1250.       env*
  1251.       use)))
  1252.  
  1253. (define (pt-recursive-let source vars vals body env use)
  1254.  
  1255.   (define (val-of var)
  1256.     (list-ref vals (- (length vars) (length (memq var vars)))))
  1257.  
  1258.   (define (bind-in-order order)
  1259.     (if (null? order)
  1260.       (pt-body source body env use)
  1261.  
  1262.       ; get vars to be bound and vars to be assigned
  1263.  
  1264.       (let* ((vars-set (car order))
  1265.              (vars (set->list vars-set)))
  1266.         (let loop1 ((l (reverse vars)) (vars-b '()) (vals-b '()) (vars-a '()))
  1267.           (if (not (null? l))
  1268.             (let* ((var (car l))
  1269.                    (val (val-of var)))
  1270.               (if (or (prc? val)
  1271.                       (set-empty?
  1272.                         (set-intersection (free-variables val) vars-set)))
  1273.                 (loop1 (cdr l)
  1274.                        (cons var vars-b)
  1275.                        (cons val vals-b)
  1276.                        vars-a)
  1277.                 (loop1 (cdr l)
  1278.                        vars-b
  1279.                        vals-b
  1280.                        (cons var vars-a))))
  1281.  
  1282.             (let* ((result1
  1283.                      (let loop2 ((l vars-a))
  1284.                        (if (not (null? l))
  1285.  
  1286.                          (let* ((var (car l))
  1287.                                 (val (val-of var)))
  1288.                            (new-seq source (env-declarations env)
  1289.                              (new-set source (env-declarations env) var val)
  1290.                              (loop2 (cdr l))))
  1291.  
  1292.                          (bind-in-order (cdr order)))))
  1293.  
  1294.                    (result2
  1295.                      (if (null? vars-b)
  1296.                        result1
  1297.                        (new-call* source (env-declarations env)
  1298.                          (new-prc source (env-declarations env) #f (length vars-b) #f vars-b
  1299.                            result1)
  1300.                          vals-b)))
  1301.  
  1302.                    (result3
  1303.                      (if (null? vars-a)
  1304.                        result2
  1305.                        (new-call* source (env-declarations env)
  1306.                          (new-prc source (env-declarations env) #f (length vars-a) #f vars-a
  1307.                            result2)
  1308.                          (map (lambda (var)
  1309.                                 (new-cst source (env-declarations env) undef-object))
  1310.                               vars-a)))))
  1311.  
  1312.           result3))))))
  1313.  
  1314.   (set-prc-names! vars vals)
  1315.  
  1316.   (bind-in-order
  1317.     (topological-sort
  1318.       (transitive-closure
  1319.         (dependency-graph vars vals)))))
  1320.  
  1321. (define (pt-begin source env use)
  1322.   (pt-sequence source (cdr (source-code source)) env use))
  1323.  
  1324. (define (pt-do source env use)
  1325.   (let* ((code (source-code source))
  1326.          (loop (new-temps source '(loop)))
  1327.          (bindings (map source-code (source-code (cadr code))))
  1328.          (vars (new-variables (map car bindings)))
  1329.          (init (map (lambda (x) (pt (cadr x) env 'TRUE)) bindings))
  1330.          (env  (env-frame env vars))
  1331.          (step (map (lambda (x)
  1332.                       (pt (if (length? x 2) (car x) (caddr x)) env 'TRUE))
  1333.                     bindings))
  1334.          (exit (source-code (caddr code))))
  1335.     (set-prc-names! vars init)
  1336.     (new-call* source (env-declarations env)
  1337.       (new-prc source (env-declarations env) #f 1 #f loop
  1338.         (new-call* source (env-declarations env)
  1339.           (new-ref source (env-declarations env) (car loop)) init))
  1340.       (list
  1341.         (new-prc source (env-declarations env) #f (length vars) #f vars
  1342.           (new-tst source (env-declarations env)
  1343.             (pt (car exit) env 'PRED)
  1344.             (if (length? exit 1)
  1345.               (new-cst (caddr code) (env-declarations env) undef-object)
  1346.               (pt-sequence (caddr code) (cdr exit) env use))
  1347.             (if (length? code 3)
  1348.               (new-call* source (env-declarations env)
  1349.                 (new-ref source (env-declarations env) (car loop))
  1350.                 step)
  1351.               (new-seq source (env-declarations env)
  1352.                 (pt-sequence source (cdddr code) env 'NONE)
  1353.                 (new-call* source (env-declarations env)
  1354.                   (new-ref source (env-declarations env)
  1355.                     (car loop))
  1356.                   step)))))))))
  1357.  
  1358. (define (pt-combination source env use)
  1359.   (let* ((code (source-code source))
  1360.          (oper (pt (car code) env 'TRUE))
  1361.          (decl (node-decl oper)))
  1362.     (new-call* source (env-declarations env)
  1363.       oper
  1364.       (map (lambda (x) (pt x env 'TRUE)) (cdr code)))))
  1365.  
  1366. (define (pt-delay source env use)
  1367.   (let ((code (source-code source)))
  1368.     (new-fut source (add-delay (env-declarations env))
  1369.       (pt (cadr code) env 'TRUE))))
  1370.  
  1371. (define (pt-future source env use)
  1372.   (let ((decl (env-declarations env))
  1373.         (code (source-code source)))
  1374.     (if (eq? (futures-method decl) OFF-sym)
  1375.       (pt (cadr code) env 'TRUE)
  1376.       (new-fut source decl
  1377.         (pt (cadr code) env 'TRUE)))))
  1378.  
  1379. ; Expression identification predicates and syntax checking.
  1380.  
  1381. (define (self-eval-expr? source)
  1382.   (let ((code (source-code source)))
  1383.     (and (not (pair? code)) (not (symbol-object? code)))))
  1384.  
  1385. (define (quote-expr? source)
  1386.   (match QUOTE-sym 1 source))
  1387.  
  1388. (define (quasiquote-expr? source)
  1389.   (match QUASIQUOTE-sym 1 source))
  1390.  
  1391. (define (unquote-expr? source)
  1392.   (match UNQUOTE-sym 1 source))
  1393.  
  1394. (define (unquote-splicing-expr? source)
  1395.   (match UNQUOTE-SPLICING-sym 1 source))
  1396.  
  1397. (define (var-expr? source env)
  1398.   (let ((code (source-code source)))
  1399.     (and (symbol-object? code)
  1400.          (not-keyword source env code)
  1401.          (not-macro source env code))))
  1402.  
  1403. (define (not-macro source env name)
  1404.   (if (env-lookup-macro env name)
  1405.     (pt-syntax-error source "Macro name can't be used as a variable:" name)
  1406.     #t))
  1407.  
  1408. (define (bindable-var? source env)
  1409.   (let ((code (source-code source)))
  1410.     (and (symbol-object? code)
  1411.          (not-keyword source env code))))
  1412.  
  1413. (define (not-keyword source env name)
  1414.   (if (or (memq name common-keywords)
  1415.           (memq name (dialect-specific-keywords
  1416.                        (scheme-dialect (env-declarations env)))))
  1417.     (pt-syntax-error source "Predefined keyword can't be used as a variable:" name)
  1418.     #t))
  1419.  
  1420. (define (set!-expr? source env)
  1421.   (and (match SET!-sym 2 source)
  1422.        (var-expr? (cadr (source-code source)) env)))
  1423.  
  1424. (define (lambda-expr? source env)
  1425.   (and (match LAMBDA-sym -2 source)
  1426.        (proper-parms? (source->parms (cadr (source-code source))) env)))
  1427.  
  1428. (define (if-expr? source)
  1429.   (and (match IF-sym -2 source)
  1430.        (or (<= (length (source-code source)) 4)
  1431.            (pt-syntax-error source "Ill-formed special form" IF-sym))))
  1432.  
  1433. (define (cond-expr? source)
  1434.   (and (match COND-sym -1 source)
  1435.        (proper-clauses? source)))
  1436.  
  1437. (define (and-expr? source)
  1438.   (match AND-sym 0 source))
  1439.  
  1440. (define (or-expr? source)
  1441.   (match OR-sym 0 source))
  1442.  
  1443. (define (case-expr? source)
  1444.   (and (match CASE-sym -2 source)
  1445.        (proper-case-clauses? source)))
  1446.  
  1447. (define (let-expr? source env)
  1448.   (and (match LET-sym -2 source)
  1449.        (let ((code (source-code source)))
  1450.          (if (bindable-var? (cadr code) env)
  1451.            (and (proper-bindings? (caddr code) #t env)
  1452.                 (or (> (length code) 3)
  1453.                     (pt-syntax-error source "Ill-formed named 'let'")))
  1454.            (proper-bindings? (cadr code) #t env)))))
  1455.  
  1456. (define (let*-expr? source env)
  1457.   (and (match LET*-sym -2 source)
  1458.        (proper-bindings? (cadr (source-code source)) #f env)))
  1459.  
  1460. (define (letrec-expr? source env)
  1461.   (and (match LETREC-sym -2 source)
  1462.        (proper-bindings? (cadr (source-code source)) #t env)))
  1463.  
  1464. (define (begin-expr? source)
  1465.   (match BEGIN-sym -1 source))
  1466.  
  1467. (define (do-expr? source env)
  1468.   (and (match DO-sym -2 source)
  1469.        (proper-do-bindings? source env)
  1470.        (proper-do-exit? source)))
  1471.  
  1472. (define (define-expr? source env)
  1473.   (and (match DEFINE-sym -1 source)
  1474.        (proper-definition? source env)
  1475.        (let ((v (definition-variable source)))
  1476.          (not-macro v env (source-code v)))))
  1477.  
  1478. (define (combination-expr? source)
  1479.   (let ((length (proper-length (source-code source))))
  1480.     (if length
  1481.       (or (> length 0)
  1482.           (pt-syntax-error source "Ill-formed procedure call"))
  1483.       (pt-syntax-error source "Ill-terminated procedure call"))))
  1484.  
  1485. (define (delay-expr? source env)
  1486.   (and (not (eq? (scheme-dialect (env-declarations env)) IEEE-SCHEME-sym))
  1487.        (match DELAY-sym 1 source)))
  1488.        
  1489. (define (future-expr? source env)
  1490.   (and (eq? (scheme-dialect (env-declarations env)) MULTILISP-sym)
  1491.        (match FUTURE-sym 1 source)))
  1492.        
  1493. (define (macro-expr? source env)
  1494.   (let ((code (source-code source)))
  1495.     (and (pair? code)
  1496.          (symbol-object? (source-code (car code)))
  1497.          (let ((macr (env-lookup-macro env (source-code (car code)))))
  1498.            (and macr
  1499.                 (let ((len (proper-length (cdr code))))
  1500.                   (if len
  1501.                     (let ((len* (+ len 1))
  1502.                           (size (car macr)))
  1503.                       (or (if (> size 0) (= len* size) (>= len* (- size)))
  1504.                           (pt-syntax-error source "Ill-formed macro form")))
  1505.                     (pt-syntax-error source "Ill-terminated macro form"))))))))
  1506.  
  1507. (define (define-macro-expr? source env)
  1508.   (and (match **DEFINE-MACRO-sym -1 source)
  1509.        (proper-definition? source env)))
  1510.  
  1511. (define (declare-expr? source)
  1512.   (match **DECLARE-sym -1 source))
  1513.  
  1514. (define (include-expr? source)
  1515.   (match **INCLUDE-sym 1 source))
  1516.  
  1517. (define (begin-defs-expr? source)
  1518.   (match BEGIN-sym 0 source))
  1519.  
  1520. (define (match keyword size source)
  1521.   (let ((code (source-code source)))
  1522.     (and (pair? code)
  1523.          (eq? (source-code (car code)) keyword)
  1524.          (let ((length (proper-length (cdr code))))
  1525.            (if length
  1526.              (or (if (> size 0) (= length size) (>= length (- size)))
  1527.                  (pt-syntax-error source "Ill-formed special form" keyword))
  1528.              (pt-syntax-error source "Ill-terminated special form" keyword))))))
  1529.  
  1530. (define (proper-length l)
  1531.   (define (length l n)
  1532.     (cond ((pair? l) (length (cdr l) (+ n 1)))
  1533.           ((null? l) n)
  1534.           (else      #f)))
  1535.   (length l 0))
  1536.  
  1537. (define (proper-definition? source env)
  1538.   (let* ((code (source-code source))
  1539.          (pattern* (cadr code))
  1540.          (pattern (source-code pattern*))
  1541.          (body (cddr code)))
  1542.     (cond ((bindable-var? pattern* env)
  1543.            (cond ((length? body 0) #t) ; an unbound variable
  1544.                  ((length? body 1) #t) ; a bound variable
  1545.                  (else
  1546.                   (pt-syntax-error source "Ill-formed definition body"))))
  1547.           ((pair? pattern)
  1548.            (if (length? body 0)
  1549.              (pt-syntax-error
  1550.               source
  1551.               "Body of a definition must have at least one expression"))
  1552.            (if (bindable-var? (car pattern) env)
  1553.              (proper-parms? (cdr pattern) env)
  1554.              (pt-syntax-error
  1555.                (car pattern)
  1556.                "Procedure name must be an identifier")))
  1557.           (else
  1558.            (pt-syntax-error pattern* "Ill-formed definition pattern")))))
  1559.  
  1560. (define (definition-variable def)
  1561.   (let* ((code (source-code def))
  1562.          (pattern (cadr code)))
  1563.     (if (pair? (source-code pattern))
  1564.       (car (source-code pattern))
  1565.       pattern)))
  1566.  
  1567. (define (definition-value def)
  1568.   (let ((code (source-code def))
  1569.         (loc (source-locat def)))
  1570.     (cond ((pair? (source-code (cadr code)))
  1571.            (make-source
  1572.              (cons (make-source LAMBDA-sym loc)
  1573.                    (cons (parms->source (cdr (source-code (cadr code))) loc)
  1574.                          (cddr code)))
  1575.              loc))
  1576.           ((null? (cddr code))
  1577.            (make-source
  1578.              (list (make-source QUOTE-sym loc) (make-source undef-object loc))
  1579.              loc))
  1580.           (else
  1581.            (caddr code)))))
  1582.  
  1583. (define (parms->source parms loc)
  1584.   (if (or (pair? parms) (null? parms)) (make-source parms loc) parms))
  1585.  
  1586. (define (proper-parms? parms env)
  1587.  
  1588.   (define (proper-parms parms seen optional-seen)
  1589.     (cond ((pair? parms)
  1590.            (let* ((parm* (car parms))
  1591.                   (parm (source-code parm*)))
  1592.              (cond ((pair? parm)
  1593.                     (if (eq? (scheme-dialect (env-declarations env)) MULTILISP-sym)
  1594.                       (let ((length (proper-length parm)))
  1595.                         (if (or (eqv? length 1) (eqv? length 2))
  1596.                           (let ((var (car parm)))
  1597.                             (if (bindable-var? var env)
  1598.                               (if (memq (source-code var) seen)
  1599.                                 (pt-syntax-error
  1600.                                   var
  1601.                                   "Duplicate parameter in parameter list")
  1602.                                 (proper-parms
  1603.                                   (cdr parms)
  1604.                                   (cons (source-code var) seen)
  1605.                                   #t))
  1606.                               (pt-syntax-error
  1607.                                 var
  1608.                                 "Parameter must be an identifier")))
  1609.                           (pt-syntax-error parm* "Ill-formed optional parameter")))
  1610.                       (pt-syntax-error
  1611.                          parm*
  1612.                          "optional parameters illegal in this dialect")))
  1613.                    (optional-seen
  1614.                     (pt-syntax-error parm* "Optional parameter expected"))
  1615.                    ((bindable-var? parm* env)
  1616.                     (if (memq parm seen)
  1617.                       (pt-syntax-error
  1618.                         parm*
  1619.                         "Duplicate parameter in parameter list"))
  1620.                       (proper-parms
  1621.                         (cdr parms)
  1622.                         (cons parm seen)
  1623.                         #f))
  1624.                    (else
  1625.                     (pt-syntax-error parm* "Parameter must be an identifier")))))
  1626.           ((null? parms)
  1627.            #t)
  1628.           ((bindable-var? parms env)
  1629.            (if (memq (source-code parms) seen)
  1630.              (pt-syntax-error parms "Duplicate parameter in parameter list")
  1631.              #t))
  1632.           (else
  1633.            (pt-syntax-error parms "Rest parameter must be an identifier"))))
  1634.  
  1635.   (proper-parms parms '() #f))
  1636.  
  1637. (define (proper-clauses? source)
  1638.  
  1639.   (define (proper-clauses clauses)
  1640.     (or (null? clauses)
  1641.         (let* ((clause* (car clauses))
  1642.                (clause (source-code clause*))
  1643.                (length (proper-length clause)))
  1644.           (if length
  1645.             (if (>= length 1)
  1646.               (if (eq? (source-code (car clause)) ELSE-sym)
  1647.                 (cond ((= length 1)
  1648.                        (pt-syntax-error
  1649.                          clause*
  1650.                          "Else clause must have a body"))
  1651.                       ((not (null? (cdr clauses)))
  1652.                        (pt-syntax-error
  1653.                          clause*
  1654.                          "Else clause must be the last clause"))
  1655.                       (else
  1656.                        (proper-clauses (cdr clauses))))
  1657.                 (if (and (>= length 2)
  1658.                          (eq? (source-code (cadr clause)) =>-sym)
  1659.                          (not (= length 3)))
  1660.                   (pt-syntax-error
  1661.                     (cadr clause)
  1662.                     "'=>' must be followed by a single expression")
  1663.                   (proper-clauses (cdr clauses))))
  1664.               (pt-syntax-error clause* "Ill-formed 'cond' clause"))
  1665.             (pt-syntax-error clause* "Ill-terminated 'cond' clause")))))
  1666.  
  1667.   (proper-clauses (cdr (source-code source))))
  1668.  
  1669. (define (proper-case-clauses? source)
  1670.  
  1671.   (define (proper-case-clauses clauses)
  1672.     (or (null? clauses)
  1673.         (let* ((clause* (car clauses))
  1674.                (clause (source-code clause*))
  1675.                (length (proper-length clause)))
  1676.           (if length
  1677.             (if (>= length 2)
  1678.               (if (eq? (source-code (car clause)) ELSE-sym)
  1679.                 (if (not (null? (cdr clauses)))
  1680.                   (pt-syntax-error
  1681.                     clause*
  1682.                     "Else clause must be the last clause")
  1683.                   (proper-case-clauses (cdr clauses)))
  1684.                 (begin
  1685.                   (proper-selector-list? (car clause))
  1686.                   (proper-case-clauses (cdr clauses))))
  1687.               (pt-syntax-error
  1688.                 clause*
  1689.                 "A 'case' clause must have a selector list and a body"))
  1690.             (pt-syntax-error clause* "Ill-terminated 'case' clause")))))
  1691.  
  1692.   (proper-case-clauses (cddr (source-code source))))
  1693.  
  1694. (define (proper-selector-list? source)
  1695.   (let* ((code (source-code source))
  1696.          (length (proper-length code)))
  1697.     (if length
  1698.       (or (>= length 1)
  1699.           (pt-syntax-error
  1700.             source
  1701.             "Selector list must contain at least one element"))
  1702.       (pt-syntax-error source "Ill-terminated selector list"))))
  1703.  
  1704. (define (proper-bindings? bindings check-dupl? env)
  1705.  
  1706.   (define (proper-bindings l seen)
  1707.     (cond ((pair? l)
  1708.            (let* ((binding* (car l))
  1709.                   (binding (source-code binding*)))
  1710.              (if (eqv? (proper-length binding) 2)
  1711.                (let ((var (car binding)))
  1712.                  (if (bindable-var? var env)
  1713.                    (if (and check-dupl? (memq (source-code var) seen))
  1714.                      (pt-syntax-error var "Duplicate variable in bindings")
  1715.                      (proper-bindings (cdr l)
  1716.                                       (cons (source-code var) seen)))
  1717.                    (pt-syntax-error
  1718.                      var
  1719.                      "Binding variable must be an identifier")))
  1720.                (pt-syntax-error binding* "Ill-formed binding"))))
  1721.           ((null? l)
  1722.            #t)
  1723.           (else
  1724.            (pt-syntax-error bindings "Ill-terminated binding list"))))
  1725.           
  1726.    (proper-bindings (source-code bindings) '()))
  1727.  
  1728. (define (proper-do-bindings? source env)
  1729.   (let ((bindings (cadr (source-code source))))
  1730.  
  1731.     (define (proper-bindings l seen)
  1732.       (cond ((pair? l)
  1733.              (let* ((binding* (car l))
  1734.                     (binding (source-code binding*))
  1735.                     (length (proper-length binding)))
  1736.                (if (or (eqv? length 2) (eqv? length 3))
  1737.                  (let ((var (car binding)))
  1738.                    (if (bindable-var? var env)
  1739.                      (if (memq (source-code var) seen)
  1740.                        (pt-syntax-error var "Duplicate variable in bindings")
  1741.                        (proper-bindings (cdr l)
  1742.                                         (cons (source-code var) seen)))
  1743.                      (pt-syntax-error
  1744.                        var
  1745.                        "Binding variable must be an identifier")))
  1746.                  (pt-syntax-error binding* "Ill-formed binding"))))
  1747.             ((null? l)
  1748.              #t)
  1749.             (else
  1750.              (pt-syntax-error bindings "Ill-terminated binding list"))))
  1751.  
  1752.      (proper-bindings (source-code bindings) '())))
  1753.  
  1754. (define (proper-do-exit? source)
  1755.   (let* ((code (source-code (caddr (source-code source))))
  1756.          (length (proper-length code)))
  1757.     (if length
  1758.       (or (> length 0)
  1759.           (pt-syntax-error source "Ill-formed exit clause"))
  1760.       (pt-syntax-error source "Ill-terminated exit clause"))))
  1761.  
  1762. (define (include-filename source)
  1763.   (source-code (cadr (source-code source))))
  1764.  
  1765. (define (begin-defs-body source)
  1766.   (cdr (source-code source)))
  1767.  
  1768. (define (length? l n)
  1769.   (cond ((null? l) (= n 0))
  1770.         ((> n 0)   (length? (cdr l) (- n 1)))
  1771.         (else      #f)))
  1772.  
  1773. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1774. ;
  1775. ; Variable dependency analysis for recursive definitions (e.g. 'letrec's).
  1776.  
  1777. (define (make-gnode label edges)
  1778.   (vector gnode-tag label edges))
  1779.  
  1780. (define (gnode? x)
  1781.   (and (vector? x)
  1782.        (> (vector-length x) 0)
  1783.        (eq? (vector-ref x 0) gnode-tag)))
  1784.  
  1785. (define (gnode-label x)        (vector-ref x 1))
  1786. (define (gnode-edges x)        (vector-ref x 2))
  1787. (define (gnode-label-set! x y) (vector-set! x 1 y))
  1788. (define (gnode-edges-set! x y) (vector-set! x 2 y))
  1789.  
  1790. (define gnode-tag (list 'gnode))
  1791.  
  1792. (define (dependency-graph vars vals)
  1793.   (define (dgraph vars* vals*)
  1794.     (if (null? vars*)
  1795.       (set-empty)
  1796.       (let ((var (car vars*)) (val (car vals*)))
  1797.         (set-adjoin (dgraph (cdr vars*) (cdr vals*))
  1798.                     (make-gnode var (set-intersection
  1799.                                       (list->set vars)
  1800.                                       (free-variables val)))))))
  1801.   (dgraph vars vals))
  1802.  
  1803. (define (transitive-closure graph)
  1804.   (define changed? #f)
  1805.   (define (closure edges)
  1806.     (list->set (set-union edges
  1807.                           (apply set-union
  1808.                                  (map (lambda (label)
  1809.                                         (gnode-edges (gnode-find label graph)))
  1810.                                       (set->list edges))))))
  1811.   (let ((new-graph
  1812.           (set-map (lambda (x)
  1813.                      (let ((new-edges (closure (gnode-edges x))))
  1814.                        (if (not (set-equal? new-edges (gnode-edges x)))
  1815.                          (set! changed? #t))
  1816.                        (make-gnode (gnode-label x) new-edges)))
  1817.                    graph)))
  1818.     (if changed? (transitive-closure new-graph) new-graph)))
  1819.  
  1820. (define (gnode-find label graph)
  1821.   (define (find label l)
  1822.     (cond ((null? l)                         #f)
  1823.           ((eq? (gnode-label (car l)) label) (car l))
  1824.           (else                              (find label (cdr l)))))
  1825.   (find label (set->list graph)))
  1826.  
  1827. (define (topological-sort graph) ; topological sort fixed to handle cycles
  1828.   (if (set-empty? graph)
  1829.     '()
  1830.     (let ((to-remove (or (remove-no-edges graph) (remove-cycle graph))))
  1831.       (let ((labels (set-map gnode-label to-remove)))
  1832.         (cons labels
  1833.               (topological-sort
  1834.                 (set-map (lambda (x)
  1835.                            (make-gnode
  1836.                              (gnode-label x)
  1837.                              (set-difference (gnode-edges x) labels)))
  1838.                          (set-difference graph to-remove))))))))
  1839.  
  1840. (define (remove-no-edges graph)
  1841.   (let ((nodes-with-no-edges
  1842.          (set-keep (lambda (x) (set-empty? (gnode-edges x))) graph)))
  1843.     (if (set-empty? nodes-with-no-edges)
  1844.       #f
  1845.       nodes-with-no-edges)))
  1846.  
  1847. (define (remove-cycle graph)
  1848.   (define (remove l)
  1849.     (let ((edges (gnode-edges (car l))))
  1850.       (define (equal-edges? x) (set-equal? (gnode-edges x) edges))
  1851.       (define (member-edges? x) (set-member? (gnode-label x) edges))
  1852.       (if (set-member? (gnode-label (car l)) edges)
  1853.         (let ((edge-graph (set-keep member-edges? graph)))
  1854.           (if (set-every? equal-edges? edge-graph)
  1855.             edge-graph
  1856.             (remove (cdr l))))
  1857.         (remove (cdr l)))))
  1858.   (remove (set->list graph)))
  1859.  
  1860. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1861. ;
  1862. ; Declaration handling:
  1863. ; --------------------
  1864.  
  1865. ; A declaration has the form: (##declare <item1> <item2> ...)
  1866. ;
  1867. ; an <item> can be one of 6 types:
  1868. ;
  1869. ; - flag declaration           : (<id>)
  1870. ; - parameterized declaration  : (<id> <parameter>)
  1871. ; - boolean declaration        : (<id>)  or  (NOT <id>)
  1872. ; - namable declaration        : (<id> <name>...)
  1873. ; - namable boolean declaration: (<id> <name>...)  or  (NOT <id> <name>...)
  1874. ; - namable string declaration : (<id> <string> <name>...)
  1875.  
  1876. (define (transform-declaration source)
  1877.   (let ((code (source-code source)))
  1878.     (if (not (pair? code))
  1879.       (pt-syntax-error source "Ill-formed declaration")
  1880.       (let* ((pos (not (eq? (source-code (car code)) NOT-sym)))
  1881.              (x (if pos code (cdr code))))
  1882.         (if (not (pair? x))
  1883.           (pt-syntax-error source "Ill-formed declaration")
  1884.           (let* ((id* (car x))
  1885.                  (id (source-code id*)))
  1886.  
  1887.             (cond ((not (symbol-object? id))
  1888.                    (pt-syntax-error id* "Declaration name must be an identifier"))
  1889.  
  1890.                   ((assq id flag-declarations)
  1891.                    (cond ((not pos)
  1892.                           (pt-syntax-error id* "Declaration can't be negated"))
  1893.                          ((null? (cdr x))
  1894.                           (flag-decl
  1895.                             source
  1896.                             (cdr (assq id flag-declarations))
  1897.                             id))
  1898.                          (else
  1899.                           (pt-syntax-error source "Ill-formed declaration"))))
  1900.  
  1901.                   ((memq id parameterized-declarations)
  1902.                    (cond ((not pos)
  1903.                           (pt-syntax-error id* "Declaration can't be negated"))
  1904.                          ((eqv? (proper-length x) 2)
  1905.                           (parameterized-decl
  1906.                             source
  1907.                             id
  1908.                             (source->expression (cadr x))))
  1909.                          (else
  1910.                           (pt-syntax-error source "Ill-formed declaration"))))
  1911.  
  1912.                   ((memq id boolean-declarations)
  1913.                    (if (null? (cdr x))
  1914.                      (boolean-decl source id pos)
  1915.                      (pt-syntax-error source "Ill-formed declaration")))
  1916.  
  1917.                   ((assq id namable-declarations)
  1918.                    (cond ((not pos)
  1919.                           (pt-syntax-error id* "Declaration can't be negated"))
  1920.                          (else
  1921.                           (namable-decl
  1922.                             source
  1923.                             (cdr (assq id namable-declarations))
  1924.                             id
  1925.                             (map source->expression (cdr x))))))
  1926.  
  1927.                   ((memq id namable-boolean-declarations)
  1928.                    (namable-boolean-decl
  1929.                      source
  1930.                      id
  1931.                      pos
  1932.                      (map source->expression (cdr x))))
  1933.  
  1934.                   ((memq id namable-string-declarations)
  1935.                    (if (not (pair? (cdr x)))
  1936.                      (pt-syntax-error source "Ill-formed declaration")
  1937.                      (let* ((str* (cadr x))
  1938.                             (str (source-code str*)))
  1939.                        (cond ((not pos)
  1940.                               (pt-syntax-error id* "Declaration can't be negated"))
  1941.                              ((not (string? str))
  1942.                               (pt-syntax-error str* "String expected"))
  1943.                              (else
  1944.                               (namable-string-decl
  1945.                                 source
  1946.                                 id
  1947.                                 str
  1948.                                 (map source->expression (cddr x))))))))
  1949.  
  1950.                   (else
  1951.                    (pt-syntax-error id* "Unknown declaration")))))))))
  1952.  
  1953. (define (add-declarations source env)
  1954.   (let loop ((l (cdr (source-code source))) (env env))
  1955.     (if (pair? l)
  1956.       (loop (cdr l) (env-declare env (transform-declaration (car l))))
  1957.       env)))
  1958.  
  1959. (define (add-decl d decl)
  1960.   (env-declare decl d))
  1961.  
  1962. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1963. ;
  1964. ; Macro handling:
  1965. ; --------------
  1966.  
  1967. (define (add-macro source env)
  1968.  
  1969.   (define (form-size parms)
  1970.     (let loop ((l parms) (n 1))
  1971.       (if (pair? l)
  1972.         (loop (cdr l) (+ n 1))
  1973.         (if (null? l) n (- n)))))
  1974.  
  1975.   (define (error-proc . msgs)
  1976.     (apply compiler-user-error
  1977.            (cons (source-locat source)
  1978.                  (cons "(in macro body)" msgs))))
  1979.  
  1980.   (let ((var (definition-variable source))
  1981.         (proc (definition-value source)))
  1982.     (if (lambda-expr? proc env)
  1983.       (env-macro env
  1984.                  (source-code var)
  1985.                  (cons (form-size (source->parms (cadr (source-code proc))))
  1986.                        (scheme-global-eval (source->expression proc)
  1987.                                            error-proc)))
  1988.       (pt-syntax-error source "Macro value must be a lambda expression"))))
  1989.  
  1990. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1991.  
  1992. (define (ptree.begin! info-port) ; initialize package
  1993.   (set! *ptree-port* info-port)
  1994.   '())
  1995.  
  1996. (define (ptree.end!) ; finalize package
  1997.   '())
  1998.  
  1999. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  2000. ;
  2001. ; Stuff local to the package:
  2002.  
  2003. (define *ptree-port* '())
  2004.  
  2005. ;==============================================================================
  2006.